home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / a-stwima.adb < prev    next >
Text File  |  1994-05-19  |  12KB  |  392 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                A D A . S T R I N G S . W I D E _ M A P S                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.2 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25.  
  26. package body Ada.Strings.Wide_Maps is
  27.  
  28.    --  The following functions replace the use of 'Min and 'Max till we
  29.    --  get those attributes implemented on type Wide_Character ???
  30.  
  31.    function Wide_Character_Min (A, B : Wide_Character)
  32.      return Wide_Character is
  33.    begin
  34.       if A < B then
  35.          return A;
  36.       else
  37.          return B;
  38.       end if;
  39.    end Wide_Character_Min;
  40.  
  41.    function Wide_Character_Max (A, B : Wide_Character)
  42.      return Wide_Character is
  43.    begin
  44.       if A > B then
  45.          return A;
  46.       else
  47.          return B;
  48.       end if;
  49.    end Wide_Character_Max;
  50.  
  51.    -----------------------
  52.    -- Local Subprograms --
  53.    -----------------------
  54.  
  55.    --  The following functions allow us simple arithmetic on wide character
  56.    --  values, the caller knows that the result is in wide character range.
  57.  
  58.    function "+" (Left : Wide_Character; Right : Natural)
  59.      return Wide_Character is
  60.    begin
  61.       return Wide_Character'Val (Wide_Character'Pos (Left) + Right);
  62.    end "+";
  63.  
  64.    function "-" (Left : Wide_Character; Right : Natural)
  65.      return Wide_Character is
  66.    begin
  67.       return Wide_Character'Val (Wide_Character'Pos (Left) - Right);
  68.    end "-";
  69.  
  70.    ---------
  71.    -- "=" --
  72.    ---------
  73.  
  74.    function "=" (Left, Right : Wide_Character_Set) return Boolean is
  75.       L1 : constant Wide_Character := Left'First;
  76.       L2 : constant Wide_Character := Left'Last;
  77.       R1 : constant Wide_Character := Right'First;
  78.       R2 : constant Wide_Character := Right'Last;
  79.  
  80.       Min    : Wide_Character := Wide_Character_Min (L1, R1);
  81.       Max    : Wide_Character := Wide_Character_Max (L2, R2);
  82.       Result : Wide_Character_Set (Min .. Max);
  83.  
  84.    begin
  85.       if Left'Length = Right'Length then
  86.          return Standard."=" (Left, Right);
  87.  
  88.       else
  89.          for J in Left'range loop
  90.             if Left (J) and then J in Right'range and then not Right (J) then
  91.                return False;
  92.             end if;
  93.          end loop;
  94.  
  95.          for J in Right'range loop
  96.             if Right (J) and then J in Left'range and then not Left (J) then
  97.                return False;
  98.             end if;
  99.          end loop;
  100.  
  101.          return True;
  102.       end if;
  103.    end "=";
  104.  
  105.    -----------
  106.    -- "and" --
  107.    -----------
  108.  
  109.    function "and" (Left, Right : Wide_Character_Set)
  110.      return Wide_Character_Set
  111.    is
  112.       L1 : constant Wide_Character := Left'First;
  113.       L2 : constant Wide_Character := Left'Last;
  114.       R1 : constant Wide_Character := Right'First;
  115.       R2 : constant Wide_Character := Right'Last;
  116.  
  117.    begin
  118.       if L1 < R1 then
  119.          if L2 < R2 then
  120.             return Null_Set;
  121.          elsif L2 < R2 then
  122.             return Standard."and" (Left (R1 .. L2), Right (R1 .. L2));
  123.          else
  124.             return Standard."and" (Left (R1 .. R2), Right);
  125.          end if;
  126.       else
  127.          return Right and Left;
  128.       end if;
  129.    end "and";
  130.  
  131.    -----------
  132.    -- "not" --
  133.    -----------
  134.  
  135.    function "not" (Right : Wide_Character_Set) return Wide_Character_Set is
  136.       Min : Wide_Character := Wide_Character'First;
  137.       Max : Wide_Character := Wide_Character'Last;
  138.  
  139.    begin
  140.       if Right'First = Wide_Character'First then
  141.          Min := Max;
  142.  
  143.          for J in Right'range loop
  144.             if not Right (J) then
  145.                Min := J;
  146.                exit;
  147.             end if;
  148.          end loop;
  149.  
  150.          if Min = Max then
  151.             return Null_Set;
  152.          end if;
  153.       end if;
  154.  
  155.       if Right'Last = Wide_Character'Last then
  156.          for J in reverse Right'range loop
  157.             if not Right (J) then
  158.                Max := J;
  159.             end if;
  160.          end loop;
  161.       end if;
  162.  
  163.       return Standard."not" (Right (Min .. Max));
  164.    end "not";
  165.  
  166.    ----------
  167.    -- "or" --
  168.    ----------
  169.  
  170.    function "or" (Left, Right : Wide_Character_Set)
  171.      return Wide_Character_Set
  172.    is
  173.       L1 : constant Wide_Character := Left'First;
  174.       L2 : constant Wide_Character := Left'Last;
  175.       R1 : constant Wide_Character := Right'First;
  176.       R2 : constant Wide_Character := Right'Last;
  177.  
  178.       Result : Wide_Character_Set (Wide_Character'range);
  179.  
  180.    begin
  181.       if L1 < R1 then
  182.          if L2 < R2 then
  183.             Result (L1 .. L2)         := Left;
  184.             Result (L2 + 1 .. R1 - 1) := (others => False);
  185.             Result (R1 .. R2)         := Right;
  186.             return Result (L1 .. R2);
  187.  
  188.          elsif L2 < R2 then
  189.             Result (L1 .. R1 - 1) := Left (L1 .. R1 - 1);
  190.             Result (R1 .. L2)     := Standard."or" (Left  (R1 .. L2),
  191.                                                     Right (R1 .. L2));
  192.             Result (L2 + 1 .. R2) := Right (L2 + 1 .. R2);
  193.             return Result (L1 .. R2);
  194.  
  195.          else
  196.             Result (L1 .. R1 - 1) := Left (L1 .. R1 - 1);
  197.             Result (R1 .. R2)     := Standard."or" (Left (R1 .. R2), Right);
  198.             Result (R2 + 1 .. L2) := Left (R2 + 1 .. L2);
  199.             return Result (L1 .. L2);
  200.          end if;
  201.       else
  202.          return Right or Left;
  203.       end if;
  204.    end "or";
  205.  
  206.    -----------
  207.    -- "xor" --
  208.    -----------
  209.  
  210.    function "xor" (Left, Right : Wide_Character_Set)
  211.      return Wide_Character_Set
  212.    is
  213.       L1 : constant Wide_Character := Left'First;
  214.       L2 : constant Wide_Character := Left'Last;
  215.       R1 : constant Wide_Character := Right'First;
  216.       R2 : constant Wide_Character := Right'Last;
  217.  
  218.       Result : Wide_Character_Set (Wide_Character'range);
  219.  
  220.    begin
  221.       if L1 < R1 then
  222.          if L2 < R2 then
  223.             Result (L1 .. L2)         := Standard."not" (Left);
  224.             Result (L2 + 1 .. R1 - 1) := (others => False);
  225.             Result (R1 .. R2)         := Standard."not" (Right);
  226.             return Result (L1 .. R2);
  227.  
  228.          elsif L2 < R2 then
  229.             Result (L1 .. R1 - 1) := Standard."not" (Left (L1 .. R1 - 1));
  230.             Result (R1 .. L2)     := Standard."xor" (Left  (R1 .. L2),
  231.                                                      Right (R1 .. L2));
  232.             Result (L2 + 1 .. R2) := Standard."not" (Right (L2 + 1 .. R2));
  233.             return Result (L1 .. R2);
  234.  
  235.          else
  236.             Result (L1 .. R1 - 1) := Standard."not" (Left (L1 .. R1 - 1));
  237.             Result (R1 .. R2)     := Standard."xor" (Left (R1 .. R2), Right);
  238.             Result (R2 + 1 .. L2) := Standard."not" (Left (R2 + 1 .. L2));
  239.             return Result (L1 .. L2);
  240.          end if;
  241.       else
  242.          return Right xor Left;
  243.       end if